perm filename GPRINT.LSP[SCH,LSP] blob
sn#688827 filedate 1982-11-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00034 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 -*- Mode:LISP Package:CHAOS base:10. fonts:MEDFNB -*-
C00008 00003
C00013 00004
C00017 00005
C00023 00006
C00030 00007
C00036 00008
C00041 00009
C00047 00010
C00051 00011
C00053 00012
C00057 00013
C00059 00014
C00063 00015
C00067 00016
C00070 00017
C00075 00018
C00079 00019
C00084 00020
C00088 00021
C00092 00022
C00095 00023
C00097 00024
C00102 00025
C00105 00026
C00107 00027
C00110 00028
C00114 00029
C00117 00030
C00121 00031
C00125 00032
C00129 00033
C00133 00034
C00136 ENDMK
C⊗;
;-*- Mode:LISP; Package:CHAOS; base:10.; fonts:MEDFNB; -*-
;NOTE THE PACKAGE IN THE MODE LINE --MUST-- BE DIFFERENT FROM ANY IN THE FILE.
;This file implements a pretty printer.
;See MIT/AIM-611 for a logical discussion of the printer in depth.
;All bugs and suggestions should be sent to BUG-GPRINT@MIT-AI.
;all internal functions and symbols are in the package GPRINT on lispm.
#M(herald gprint)
(declare #M(macros nil) (fixnum i j k spaces default-spaces indent max))
#Q(eval-when (eval load compile)
(setq external-atoms
'(Gcheckrecursion prinmode prinlevel prinlength prinendline
prinstartline Gfn-format Gapply-format Gforce-mores
grind-macroexpanded Gsymbol-car-format Gnon-symbol-car-format
Gspecial-formatters Glist-formatters Garray-formatters
Goverriding-list-formatters Gatom-pcode Gprinlevel-abbrev
Gset-up-printer Gprint1 Gprintc Gprint Gexplode Gexplodec plp pl
GF defGF GFN Gformat GQ Gcheck-indentation Gdispatch GF-end))
(eval `(package-declare GPRINT global 1000 () ;must use eval
(extern . ,external-atoms)))
(mapc #'globalize external-functions) ;this shouldn't be done this way.
(pkg-goto 'GPRINT)) ;note that this only lasts the duration of the load.
;This describes the basic fns supplied to the user.
;GPRINT1 (obj &optional file format prinlevel prinlength
; prinendline prinstartline)
; - the analog of PRIN1. [The name GPRIN1 is already used for a fn in
; the standard maclisp grinder UGH.] (Note that in MacLisp file can be a
; list of files.) A number of control parameters can
; be specified as additional optional args. If any of the control args
; is unspecified then it defaults to the value in the corresponding
; special variable. The format arg is used as the format function
; to start formatting the object at the top level.
; Note that this and all of the other printing functions below return T
; in MACLISP, and no return value at all on the LISPM.
;GPRINTC (obj &optional file format prinlevel prinlength
; prinendline prinstartline)
; - the analog of PRINC.
;GPRINT (obj &optional file format prinlevel prinlength
; prinendline prinstartline)
; - the analog of PRINT.
;PL (obj &optional file format)
; - an abbreviation for (GPRINT obj file format NIL NIL NIL NIL).
;GEXPLODE (obj &optional format prinlevel prinlength
; prinendline prinstartline)
; - this is the analog of EXPLODE. It returns a list of
; character objects corresponding to how the obj would GPRINT1.
;GEXPLODEC (obj &optional format prinlevel prinlength
; prinendline prinstartline)
; - like EXPLODE but for GPRINTC.
;PLP fexpr (args) - this is similar to GRINDEF but calls GPRINT. Each
; arg is either a symbol in which case all its properties are printed out,
; or a list whose car is a symbol and whose cdr is a list of specifc
; properties to print.
;GSET-UP-PRINTER () - this sets up GPRINT1 as the top level lisp printer,
; and sets up some usefull interrupt characters.
; In MACLISP ↑S stops printing, ↑C continues it, and ↑P reprints.
; In LISPM terminal←stop-output stops printing,
; terminal←resume continues it,
; terminal←resume with an argument reprints.
;GF macro (template . args)
; This is a macro that creates code which formats the args as specified
;by the template. The template is a string of single character
;commands, some of which can be followed by a parameter. There are three
;kinds of parameters:
;
;n - Some commands take a number as a parameter. This number
; should be an integer optionally beginning with a "-" and/or ending
; with a ".". Alternately, it can be omitted in which case a
; default value is used.
;f - Some commands take a function name as a parameter. This name
; is an arbitrary symbol possibly containing ":". Case does not
; matter. The symbol must be terminated by a blank. Function name
; parameters cannot be omitted. They have no default values.
;# - This can be used in place of any numeric parameter or any
; function name parameter. It indicates that the next input to GF
; should be used as the parameter, instead of a literal value.
;
;The commands which can be used in a template are divided into several
;categories. The first set is used to parse the structure of the
;arguments to GF so that their parts can be accessed.
;
;[...] - This is used to access the internal elements of an item
; which is a list. The template inside the brackets refers to the
; elements of the list. If the item is not a list, then no formatting
; of it, or anything inside it, is done. Processing begins by
; considering each element of this list in turn. As soon as the list is
; exhausted, control skips out of the subtemplate and continues after
; its end. This is done even if there is more stuff left in the
; subtemplate. Special code is included to deal with the possibility of
; unexpectedly encountering a non-NIL atomic CDR. If this
; happens it is automatically formatted to appear after a ".".
;. - This is valid only inside a [...]. It specifies that the
; next item is the whole sublist left to process by [...] rather
; than its CAR. For example, (GF "[P←P←.P]" '(1 2 . 3)) is the
; same as (GF "P←P←P" 1 2 3). Note that when a "." is used,
; normal checking for the end of the list in the [...] is
; suppressed. For example, (GF "[P←.P←]" '(1)) is equivalent to
; (GF "P←P←" 1 NIL). The NIL at the end of the list is
; explicitly picked up by the ".", and a blank will be printed at
; the end. This happens even though the [...] template would
; normally have terminated right after the first P.
;<...> - This can only be used directly inside [...] (or
; (...)). It specifies an indefinite repeat block. This is used to
; specify a template for a list of unknown length.
;The next set of commands are used to specify how individual items are
;printed out.
;
;P - Print the corresponding item using the default printer
; (PRINC if GPRINC was called or PRIN1 if GPRINT
; or GPRINT1 was called).
;C - Print the corresponding item using PRINC.
;S - Print the corresponding item using PRINC but do not
; count it as one of the items printed from the point of view of length
; abbreviation.
;I - Ignore the corresponding item.
;'...' - Print the indicated literal using PRINC and do not
; count it as one of the items printed from the point of view of length
; abbreviation. Note that in the literal "''" stands for "'".
;* - This specifies that GDISPATCH should be called in order to
; format the corresponding item.
;&f - Call the function f with no arguments at this
; point.
;%f - This specifies that the function f should be called
; in order to format the corresponding item. (Note if f is #
; then the argument which is used as the function follows the argument
; which is formatted.)
;$f - The dollar sign command specifies that GDISPATCH
; should be called in order to format the corresponding item, but that
; the function f should be passed to GDISPATCH as a suggestion
; of how to format the item. (Note if f is # then the argument
; which is used as the function follows the argument which is
; formatted.) The difference between $f and %f is
; that with $f GDISPATCH gets control. As a result, if the
; item is not a list, or if some function on
; GOVERRIDING-LIST-FORMATTERS formats it, then the function f
; will not get used.
;$/".../" - In addition to the name of a function, the parameter
; to $ can be a literal template which is converted into a function
; to use. (Note that the quotes have to be slashified in order to read
; in inside a quoted string.) The formatting function produced is
; compiled out of line. As a result, if there is a # format code
; in it, the argument to GF that this refers to will be compiled
; out of line. In order for this to work any variables this refers to
; must be declared special.
;The next commands are used to specify the nested structure of the
;output (which need not be the same as that of the input).
;
;{n...} - This indicates a substructural unit in the output. The
; parameter specifies what indentation to use when printing out the
; items inside the substructure if the substructure cannot be printed on
; a single line. (If the indentation is specified to be zero then the
; substructure is not counted as increasing the depth from the point of
; view of depth abbreviation.) The default parameter value is
; calculated as the sum of the lengths of the first thing printed in the
; substructure, and any literals before it and any spaces after it.
;(n...) - This is a useful abbreviation in the situation where
; the nested structure of the output is the same as the nested structure
; of the input, and when you want to print parentheses around the
; structure. It is an abbreviation for {n'('[...]')'}.
; Additionally, if the (n...) is nested more directly inside
; [...] than inside $ then it is treated as an abbreviation for
; $/"{n'('[...]')'}/". In other words, if the item whose format
; is being specified by the (n...) was passed through
; GDISPATCH for dispatching then the $ format code is used to
; force the list to dispatch through GDISPATCH. This prevents the
; format from blowing up when the item is not a list. (Note the comment
; about # inside $/".../" above.)
;
;The final set of commands specifies spacing and where and when carriage
;returns should be printed.
;
;A - Do a line break here always.
;! - Same as A.
;N - Do a line break here if required for normal mode printing.
; I.e. if and only if the structure immediately containing this point
; cannot be printed on a single line.
;- - (Minus) Abbreviation for "←N" which is what you usually want.
;B - Do a line break here if required for block mode printing. This
; is the same as N except that even if the immediately containing
; structure is being broken up a line break will not be put here
; as long as the following structure can be printed on the end
; of the current line and the prior structure at this level
; was printed on a single line.
;, - (Comma) Abbreviation for "←B" which is what you usually want.
;←n - Print n (default 1) spaces. (Note that spaces are
; elided if they are the first or last thing on a line).
;Tn - Tab over. Moves to a place where the character position
; relative to the current indentation is congruent to zero modulo n.
; (Doesn't move at all if it doesn't have to.) When necessary, a default
; tab size is calculated based on the length of the other items in the
; substructure.
;; - (Semicolon) Abbreviation for "←TB" which is what you often want.
;
;E - This is unlike everything else in that it takes place at the time
; things are printed rather than at the time they are formatted. When the
; output routine gets to this point in printing, the arg to GF corresponding
; to the E is EVALed (out of line). This is useful for getting information
; about the state of the printing process. It should NOT be used to print
; anything out because the output routine won't realize that anything was
; printed and its character position calculations will be wrong.
;
;The characters SPACE, TAB, CR, and LF are all ignored.
; Any other character is an error.
;
;The fact that GF is a macro saves time by parsing the template
;at compile time, and producing efficient code to do the formatting.
;This does waste space however. It is to your advantage to make each
;template as short as possible.
;the following documents the internals of the system by describing
;each of the internal variables. Each little description begins with
;the name of the variable, and a type descriptor: # means fixnum, +#
;means non-negative fixnum, upper case terms are constants.
;First we have a number of standard system variables that this refers
;to. Since they are standard they are only very briefly described here.
;the system treats them in essentially an exactly standard way.
(defvar PRINLEVEL) ;+#/NIL - controls depth abbreviation of substructures
;"#" or "**" is printed in place of elided things.
(defvar GPRINLEVEL-ABBREV #M'|#| #Q'|**| "the thing to print when abbreving")
(defvar PRINLENGTH) ;+#/NIL - controls length abbreviation of lists as ...
#M(defvar ↑R) #M(defvar ↑W) #M(defvar OUTFILES)
;these control the destination of default output for MACLISP.
#M(defvar TYO) ;this is the default tty output for MACLISP.
#Q(declare (special TERMINAL-IO ;what T means as output on LISPM.
STANDARD-OUTPUT)) ;default tty output for LISPM.
(defvar GRIND-MACROEXPANDED) ;T/NIL controls printing of MACROEXPANDED forms.
;next there are a few new user control variables and keywords.
(defvar GSHOW-ERRORS nil "T/NIL controls GPRINT's error handling")
; If nil Gprint does an errset in order to
; catch any errors that happen during printing. This is handy but
; makes it hard to figure the errors out. Set it to T to debug.
(defvar GFORCE-MORES T "T/NIL always forces mores when GPRINTing")
; If this is T then things are kludged so that you
; get more processing all of the time. Otherwise mores are
; suppressed if the printing is initiated with 7 lines of
; the bottom of the screen.
(defvar PRINENDLINE 4 "+#/NIL truncates GPRINTing after # lines")
; As the printer prints it counts lines (see the
; description of GLINENO below). If the output goes on for more
; than PRINENDLINE lines, then it is truncated. The printer prints
; '| ---| at the end of the PRINEDLINEth line, and stops. It can be
; continued by calling GCONTINUE. (Note NIL is the same as infinity.)
(defvar PRINSTARTLINE nil "+#/NIL GPRINTing is supressed before # line")
; As the printer prints it counts lines (see the
; description of GLINENO below). While GLINENO is less than
; PRINSTARTLINE the printer does no actual output. (This is used
; for example by GCONTINUE.) (Note NIL is the same as 0.)
(defvar GCHECKRECURSION T "T/NIL causes GPRINT to check for circularity")
; If this is T then the printer checks for
; circularity in the object it is printing.
; (This is rather expensive, but not prohibitively so.) When a circular
; reference to an object is encountered, it is replaced in the output by
; "↑N" or "%N". "%N" is only used in a list. It is used
; when the CDR a list is EQ to an earlier CDR in the
; same list. In this case N is the number of CDRs
; separating the two positions. "↑N" is used in other situations.
; Here, N indicates that N selector operations (CAR,
; CXR, AREF; but not CDR) were performed between the first
; occurence of the object and the second. It is possible (but not easy)
; to reconstruct the exact shape of the object from what was printed.
; However, the main purpose is just to print something more readable
; than what you would otherwise see. An important feature of the way
; this abbreviation is done is that it is completely orthoginal to the
; rest of the formatting process so that it works no matter what kinds
; of user formatting functions are written.
;
;the result of (LET ((X '(A (B 1 2 3) 4)))
; (RPLACD (CDR X) (CDR X))
; (RPLACA (CDADR X) X)
; (RPLACA (CDDADR X) (CADR X))
; (RPLACD (CDDADR X) (CDADR X))
; X)
;prints as (A (B ↑2 ↑1 . %2) . %1)
(defvar PLP nil "saves the last argument to the fn PLP")
(defvar PLP-PROPERTIES '(:function :value) "the properties printed by PLP")
;these specify what formatting functions to use for data structures
;:GFORMAT-SELF message - if an EXTEND (or other USRHUNK in MACLISP) or
; an INSTANCE, ENTITY, or NAMED-STRUCTURE (in LISPM) is set up so
; that it will process this message type, then it is sent a message
; in order to format itself. It gets one argument (the object itself)
; in addition to any arguments which are supplied
; by the message sending mechanism.
(defvar GSPECIAL-FORMATTERS nil "list of format fns for arbitrary things")
; These are tested before all dispatching and override all other formats.
#M(defvar GHUNK-FORMATTERS nil "list of format fns for hunks")
; When a hunk (that isn't a user hunk) is to be
; printed, then each of these is evaluted in turn. If any of them returns
; T then it is assumed that it did the appropriate formatting and work
; stops. If they all return NIL then the default formatting ocurs.
(defvar GARRAY-FORMATTERS nil "list of format fns for arrays")
; If an array (which isn't a named structure) needs to be printed, then
; each of these is evaluated in turn. If any of them returns
; T then it is assumed that it did the appropriate formatting and work
; stops. If they all return NIL then the default formatting occurs.
(defvar GPRINT-ARRAY-CONTENTS T "T/NIL causes GPRINTing of array contents")
; This controls the default formatting of
; arrays. If T then the printer prints out the
; contents of one and two dimensional arrays.
(defvar GOVERRIDING-LIST-FORMATTERS nil "list of format fns for lists")
; If a list needs to be
; formatted then each of these fns is checked to see if it can do the job.
(defvar GLIST-FORMATTERS nil "list of format fns for lists")
; If a list needs to be formatted
; which DOES NOT HAVE A FORMATTING FN SUPPLIED TO GDISPATCH then these
; formatters are also tried.
(defvar GSYMBOL-CAR-FORMAT ':G1Tblock "format for atom car data lists")
; This specifies what
; format the system should use as a default for formatting lists
; whose cars are symbols that are not FBOUNDP (eg random functional
; looking data). This is initialized so that these print out in a
; tabular form. If you want them to print out in functional form like
; the old grinder did bind this to ':Gfn-format.
(defvar GNON-SYMBOL-CAR-FORMAT ':G1Tblock "format for non-atom car data lists")
; This specifies what
; format the system should use as a default for formatting lists
; whose cars are not symbols, and are not lambda expressions (eg
; random data). This is initialized so that these print out in a
; tabular form. (If you want them to print out in miser form like
; the old grinder did, bind this to ':1MISER.)
(defvar GAPPLY-FORMAT ':Gapply-format "format for literal LAMBDA applications")
; This is used as the format for lists whose
; cars are lambda expressions.
(defvar GFN-FORMAT ':Gfn-format "format for function applications")
; This is used as the format for lists whose cars
; are atoms which are function names
;:GFORMAT property - If a symbol is given a value for this property
; then it will by used as the default formatting function to call in
; order to format a list that begins with this symbol.
(defvar GSUGGESTED-FORMAT)
; Arg to GDISPATCH. This holds the format fn which is passed
; to Gdispatch in order to format the object. It is available
; so that some other format fn which is overriding this one
; can refer to it.
;Next we have a number of variables which the system uses to
;communicate with itself. You should never ever change any of
;their values. The system rebinds all of these variables so that
;it is reentrant. It will work right if you use it to print something
;when it was interrupted in the middle of printing something else.
;The first set of these encode the arguments and environment input to
;the fn GFORMAT-OBJ. They control the form of the printing process.
(defvar GPRINLEVEL) (defvar GPRINLENGTH)
(defvar GPRINENDLINE) (defvar GPRINSTARTLINE)
; +# - these reflect the values of the corresponding user control variables.
; They are kept seperate for 2 reasons. 1- it is easier to deal
; with them because they are always numbers. 2- they are insulated
; from any changes to the user control variables during a single
; call to the printer.
(defvar GATOM-PCODE)
; :PRIN1/:PRINC - specifies how to print atoms encountered in
; the object printed.
(defvar GEXPLODING)
; If non nil, then this keeps a growing list of the result
; created when the printer is used to explode something instead of
; print it.
(defvar GOUT)
; This specifies where the output is going to go.
(defvar Gmainfile)
; This is the primary output (on the Lispm this is the same as GOUT).
(defvar GLINELEN)
; +# - the line length of the output device minus 5. (This
; reduction is a fudge factor that leaves room for trailing parens.)
(defvar GINITIAL-CHARPOS)
; +# - this is the character position where printing
; is to begin. The printer will NEVER go left of this position
; while printing.
(defvar GNOWPRINTING nil "T if GPRINT is in operation")
; T/NIL - if T this signifies that the printer is being reentered.
;These variables are used to control the fn Gredo.
(defvar GABBREVED)
; T/NIL - this is set to T if the object being printed was
; abbreviated in any way.
(defvar GTRUNCATED nil)
; If GABBREVED is T, then this variable is set to record
; the state of the printing process so that it can be continued, or
; redone. Note that this information for an incomplete print will
; be saved until another incomplete print occures.
;These variables are used when checking for circularity.
(defvar GPARENTS nil)
; Array - this is used to remember the objects which have beed
; visited already. It acts as a stack.
(defvar GRPTR)
; +#/-1 - this points to the top of the above stack. It is
; repeatedly bound and unbound as well as incremented, so that the
; stack pushes and pops in occordance with the nested structure of
; the object being printed.
;Next there are several variables which are used by GQ as it queues up
;the stuff to be printed. Primary amoung these is the queue itself.
;Note that by managing storage in this queue itself, the printer does
;virtually no consing at all under normal operation.
(defvar GQUEUE nil)
; array - this holds a queue of the formatting entries as they
; are produced. The queue holds three pieces of information about
; each entry. (note that there are special macros below to make
; referencing these fields more mnemoinic.)
;1. Gtype - :START/:END/:PRIN1/:PRINC/:SPECIAL/:SPACE/:TAB/:NEWLINE/:EVAL
; this specifies the type of the entry.
;2. Gobj - some item of information. what it means depends on the type.
; :START #/NIL - the amount of indentation. (Computed based on the first
; two items in the substructure if NIL.)
; :END NIL - ignored.
; :PRIN1 - object to prin1.
; :PRINC - object to princ.
; :SPECIAL - object to princ, but not counted as part of the number of
; items printed at this level.
; :SPACE +# - of spaces to print if not at start or end of a line.
; :TAB +#/NIL - the tab size (estimated by the system if NIL).
; :NEWLINE :ALWAYS/:NORMAL/:BLOCK - (says when to newline).
; :EVAL - a sexpr which is evaluated. the printer first makes sure that
; all pending output is performed and then evaluates the sexpr.
; This makes it possible for you to make free form extensions to
; the printer. However, you should realize that you are playing
; with fire if you do this.
;3. Gsize #/NIL - the print length of the associated structure or NIL if this
; length is not known. (In general printing will be delayed until the
; length is known.) For :PRINC, :PRIN1, :SPECIAL, :SPACE
; this is just the print size of the object. For :END, :TAB then
; this is set to 0 and is just ignored. For :START this starts out
; as NIL indicating that the print length is unknown, and is set to
; the length of the whole substructure when the corresponding end
; is reached. For :NEWLINE, if the obj is :ALWAYS or :NORMAL then
; the size is set to 0 and ignored. If the obj is
; :BLOCK, then it starts as NIL, and is not updated to the
; corrected size until the size of the :PRINC, :PRIN1, :SPECIAL,
; :SPACE, :END, :START following it is known.
(defvar GQL)
; +# - this points to the next entry to dequeue
(defvar GQR)
; +# - this points to the spot where the next entry should be put
; (the queue is empty when (= GQL GQR)).
(defvar GTSIZE)
; +# - the total size of everything in GQUEUE up to GQR.
(defvar GLSIZE)
; +# - the total size of everything in GQUEUE up to GQL (ie
; everything that has been poped off). The total size of the stuff
; that is queued but not yet processed is (- GTSIZE GRSIZE).
(defvar GQS nil)
; array - this holds things you need to remember while the subparts
; of a structure are being queued up.
;1. Gbegin +#/-1 - the place in Gq where the corresponding substructure starts
; (-1 if this spot is no longer in the queue.)
;2. Glevel +# - the depth of this structure in the overall structure. (note
; that start entries with indentations of 0 are not
; counted) (This is used to control PRINLEVEL abbreviation.)
;3. Glength +# - the number of PRIN1, PRINC, and substructure items in this
; substructure so far. (this is used to control PRINLENGTH
; abbreviation.)
;4. Gsave-Gtsize +# - a saved value of Gtsize. (Used when computing
; the actual length of a substructure.)
(defvar GQSP)
; +# - stack pointer for GQS.
;Then there are a group of variables that hold the state of the output
;actually being produced.
(defvar GLINENO)
; +# - this counts the lines printed, with the
; line the print was initiated on as line 0. (Therefore the first
; line printed by a Gprint1 is line 0 and the first one printed by a
; Gprint is line 1.)
(defvar GFREELEN)
; +# - this keeps track of how much space is left at the end
; of the current line. The charcter position is (- GLINELEN GFREELEN).
(defvar GPENDING)
; +# - this is the number of spaces (caused by (GQ ':SPACE #)
; and (GQ ':TAB #) requests) which have been logically
; printed, but have not actually been printed yet. They will not be
; printed until some non blank object must be printed, and their
; printing will be aborted if a new line is forced before then. (Ie
; trailing blanks are never printed.)
(defvar GPENDING-NEWLINE)
; T/NIL - if T then a new line must be done before
; anything more can be printed out. It will not actually be done
; until some non blank thing has to be printed.
(defvar GDEPTH)
; # - this is a little hard to describe. It records the
; relative depth of the item on the top of the queue in the obj
; being printed. If it is 0 then this item is at the top level
; inside the current substructure which the printout fn has decided
; must be broken up. If it is positive, then the item is at a
; deeper level, and therefore is in a substructure which the
; printout fn has already determined will fit on the current line.
; If it is negative, then this means that (- GDEPTH) broken up
; substructures have ended on the current line so far.
(defvar GPS nil)
; array - this is a stack which is used to hold information that
; must be remebered when the printout fn goes down a level and
; breaks up a substructure. It has two coponents:
;1. Gtabsize +#/-1 - the appropriate tab size to use. (-1 if not yet known.)
;2. Gpindent +# - the appropriate indentation to use for the next thing.
(defvar GPSP)
; +# - this is the stack pointer for GPS.
(defvar GF-ARGS)
; This is used by the macro GF.
;an important issue to note is that on the LISPM, at least Gqueue, Gqs, Gps,
;Gparents, and Gtruncated should be bound seperately in each lisp listener.
;in fact probably many of the other control variables probably should be too.
;The problem is that as things stand now, they aren't bound anywhere!
;For debugging, this lets you see easily what is in the various vectors
(eval-when (eval)
(defun sq ()
(terpri) (princ '|type obj size|)
(do ((i gql (1+ i))
(k 0 (cond ((zerop k) 2) (t (1- k)))))
((= i (+ gqr 3)))
(cond ((zerop k) (terpri)))
(prin1 (arraycall nil Gqueue i))
(cond ((zerop k) (princ '| |)))
(tyo 9.)))
(defun sqs ()
(print `((Gtsize ,Gtsize) (Glsize ,Glsize) (Grptr ,Grptr)))
(terpri) (princ '|begin level length tsize|)
(do ((i 0 (1+ i))
(k 0 (cond ((zerop k) 3) (t (1- k)))))
((= i (+ Gqsp 4)))
(cond ((zerop k) (terpri)))
(prin1 (arraycall fixnum Gqs i)) (tyo 9.)))
(defun sps ()
(print `((Glineno ,Glineno) (Gfreelen ,Gfreelen) (Gdepth ,Gdepth)
(Gpending ,Gpending) (Gpending-newline ,Gpending-newline)))
(terpri) (princ '|tab indent|)
(do ((i 0 (1+ i))
(k 0 (cond ((zerop k) 1 ) (t (1- k)))))
((= i (+ Gpsp 2)))
(cond ((zerop k) (terpri)))
(prin1 (arraycall fixnum Gps i)) (tyo 9.))))
;these macros just make accessing the above things easier.
(defun Gtype macro (body) `(Gaccess .,body))
(defun Gobj macro (body) `(Gaccess .,body))
(defun Gsize macro (body) `(Gaccess .,body))
(defun Gbegin macro (body) `(Gaccess .,body))
(defun Glevel macro (body) `(Gaccess .,body))
(defun Glength macro (body) `(Gaccess .,body))
(defun Gsave-Gtsize macro (body) `(Gaccess .,body))
(defun Gtabsize macro (body) `(Gaccess .,body))
(defun Gpindent macro (body) `(Gaccess .,body))
(defun Gaccess macro (whole-body)
(let ((body (cdr whole-body)))
(displace body
(let* ((field (car body))
(vect (caseq field
((Gtype Gobj Gsize) 'Gqueue)
((Gbegin Glevel Glength Gsave-Gtsize) 'Gqs)
((Gtabsize Gpindent) 'Gps)
(T (error '|GACCCESS -- bad field name| body))))
(type (cdr (assq vect '((Gqueue)(Gqs . fixnum)(Gps . fixnum)))))
(offset (cdr (assq field '((Gtype . 0)(Gobj . 1)(Gsize . 2)
(Gbegin . 0)(Glevel . 1)
(Glength . 2)(Gsave-Gtsize . 3)
(Gtabsize . 0)(Gpindent . 1)))))
(index (cond ((null (cdr body))
(cdr (assq vect '((Gqueue . Gql)(Gqs . Gqsp)
(Gps . Gpsp)))))
(T (cadr body))))
(spot (cond ((zerop offset) index)
((equal index 0) offset)
(T `(+ ,index ,offset)))))
`(arraycall ,type ,vect ,spot)))))
(defun Gpush macro (body)
(displace body
(let* ((vector (cadr body))
(info (cdr (assq vector '((Gqueue Gqr 3. nil)(Gqs Gqsp 4. fixnum)
(Gps Gpsp 2. fixnum))))))
`(cond (;note that it is vital that the dimension is congruent to
;zero mod the step size so that this test actually works.
(not (> (array-dimension-n 1 ,vector)
(setf ,(car info) (+ ,(car info) ,(cadr info)))))
(*rearray ,vector ',(caddr info)
(+ ,(car info) ,(* (cadr info) 20.))))))))
(defun Gpop macro (body)
(displace body
(let* ((vector (cadr body))
(info (cdr (assq vector '((Gqueue Gql -3.)(Gqs Gqsp 4.)
(Gps Gpsp 2.))))))
`(setf ,(car info) (- ,(car info) ,(cadr info))))))
;this is for lisp machine compatability
#M
(defun Glinel macro (body) (displace body `(linel ,(cadr body))))
#Q
(defun Glinel macro (body)
`(cond ((memq ':size-in-characters
(funcall ,(cadr body) ':which-operations))
(funcall ,(cadr body) ':size-in-characters))
(T 94.)))
#M
(defun Gcursorpos macro (body)
(displace body
`(cond ((memq 'cursorpos (status filemode ,(car (last body))))
(cursorpos .,(cdr body))))))
#Q
(defun Gcursorpos macro (body)
(cond ((null (cddr body))
`(cond ((memq ':read-cursorpos
(funcall ,(cadr body) ':which-operations))
(multiple-value-bind (x y)
(funcall ,(cadr body) ':read-cursorpos ':character)
(cons y x)))))
(T `(cond ((memq ':set-cursorpos
(funcall ,(car (last body)) ':which-operations))
(cursorpos .,(cdr body)))))))
#M
(defun Gcharpos macro (body) (displace body `(charpos ,(cadr body))))
#Q
(defun Gcharpos macro (body) `(or (cdr (Gcursorpos ,(cadr body))) 0))
#Q
(defun *rearray macro (body)
`(adjust-array-size ,(cadr body) ,(cadddr body)))
;this macros are at the center of the formatting system. They make
;it easy to define simple formatting functions.
(eval-when (eval load compile)
(defun (GF macro) (body)
(displace body
`(progn .,(GF-code (GF-group (GF-parse3 (GF-parse2 (GF-parse1 (cadr body)))
(cddr body)))))))
(defun (defGF macro) (body)
(displace body `(defun (,(cadr body) :Gformat) (|gf|)
(GF ,(caddr body) |gf|))))
(defun (GFN macro) (body)
(displace body `(function (lambda (|gf|) (GF ,(cadr body) |gf|)))))
(defun (Gformat macro) (body)
(displace body
(let* ((file (cadr body))
(template (caddr body))
(args (cdddr body))
(arg `(list ,@ args 'Gformat-end))
(gf `(GFN ,(format nil "[}a]" template))))
(cond (file `(Gprint1 ,arg ,file ,GF nil nil nil nil))
(T `(implode (Gexplode ,arg nil ,gf nil nil nil nil)))))))
;this is an example showing how the macro expansion works.
;(GF-parse1 "(P<←(P)B>)")
;(OPEN NIL P < ← NIL OPEN NIL P CLOSE B > CLOSE)
;
;(GF-parse2 *)
;(START NIL QUOTE '|(| GO-IN P < ← NIL
; START-SUB START NIL QUOTE '|(| GO-IN P GO-OUT QUOTE '|)| END END-SUB
; B > GO-OUT QUOTE '|)| END)
;
;(GF-parse3 * '(item))
;(START NIL QUOTE '|(| GO-IN ITEM P |gf| X < ← NIL
; START-SUB |gf| START NIL QUOTE '|(| GO-IN (CAR |gf|) P |gf| X GO-OUT QUOTE '|)| END END-SUB
; X B > GO-OUT QUOTE '|)| END)
;
;(GF-group *)
;(START NIL QUOTE '|(| GO-IN ITEM (P |gf| X < ← NIL
; START-SUB |gf| (START NIL QUOTE '|(| GO-IN (CAR |gf|) (P |gf| X) QUOTE '|)| END)
; X B >) QUOTE '|)| END)
;
;(GF-code *)
;((GQ ':START NIL)
; (GQ ':SPECIAL '|(|)
; (LET ((|gf| ITEM))
; (PROG NIL
; (COND ((NOT (PAIRP |gf|)) (RETURN NIL)))
; (GQ GATOM-PCODE (car |gf|))
; (COND ((GF-END (SETQ |gf| (CDR |gf|))) (RETURN NIL)))
; L (GQ ':SPACE 1)
; (GDISPATCH
; (FUNCTION
; (LAMBDA (|gf|)
; (GQ ':START NIL)
; (GQ ':SPECIAL '|(|)
; (LET ((|gf| |gf|))
; (PROG NIL
; (COND ((NOT (PAIRP |gf|)) (RETURN NIL)))
; (GQ GATOM-PCODE (car |gf|))
; (COND ((GF-END (SETQ |gf| (CDR |gf|))) (RETURN NIL)))))
; (GQ ':SPECIAL '|)|)
; (GQ ':END NIL)))
; (car |gf|))
; (COND ((GF-END (SETQ |gf| (CDR |gf|))) (RETURN NIL)))
; (GQ ':NEWLINE ':BLOCK)
; (GO L)))
; (GQ ':SPECIAL '|)|)
; (GQ ':END NIL))
;This scans the template string and produces a sequence of tokens.
;each command is converted to an atom (case ignored) and the
;parameters are parsed. Some of the commands are renamed so that
;emacs will be happier with the file; their character codes are
;refered to directly in octal.
; (=50 -> open )=51 -> close {=173 -> start }=175 -> end
; [=133 -> go-in ]=135 -> go-out $/" -> start-sub /" -> end-sub
; ' -> quote . -> period
(defun GF-parse1 (string)
(prog (chars result n c)
(setq chars (exploden string))
L (cond ((null chars) (return (nreverse result))))
(setq n (pop chars))
(cond ((member n '(#\sp #\tab #\cr #\lf)) (go L)))
(setq c (cdr (assoc n
`((#o50 OPEN)(#o51 CLOSE)(#o133 GO-IN)(#o135 GO-OUT)(#o173 START)(#o175 END)
(#/' QUOTE)(#o56 PERIOD)(#/$ $)(#/" END-SUB)(#/< <)(#/> >)(#/% %)(#/& &)
(#/← ←)(#/* *)(#/- ← NIL N)(#/! A)(#/, ← NIL B)(#/; ← NIL T NIL B)
(#/A A)(#/a A)(#/B B)(#/b B)(#/C C)(#/c C)(#/E E)(#/e E)(#/I I)(#/i I)
(#/N N)(#/n N)(#/P P)(#/p P)(#/T T)(#/t T)(#/S S)(#/s S)))))
(cond ((and chars (= (car chars) #/") (equal c '($)))
(pop chars)
(setq c '(START-SUB))))
(cond ((null c) (error '|GF - unknown character| (list n string))))
R (cond ((cdr c) (push (pop c) result) (go R))
(T (setq c (car c)) (push c result)))
(cond ((memq c '(QUOTE $ % & ← T OPEN START))
(push
(caseq c
(QUOTE
(prog (temp)
L (cond ((null chars) (error '|GF - unmatched '| string))
((= (car chars) n) (pop chars)
(cond ((or (null (cdr chars))
(not (= (car chars) n)))
(return `',(implode (nreverse temp)))))))
(push (pop chars) temp)
(go L)))
(($ % &)
(prog (temp)
(cond ((= (car chars) #o43) (pop chars) (return '|#|)))
L (cond ((or (null chars)
(= (car chars) n) (= (car chars) #\space))
(pop chars)
(return `',(readlist (nreverse temp)))))
(push (pop chars) temp)
(go L)))
((← T OPEN START)
(prog (temp)
(cond ((null chars) (go E)))
(cond ((= (car chars) #o43) (pop chars) (return '|#|)))
(cond ((member (car chars) '#.(exploden "-01234567890"))
(push (pop chars) temp))
(T (go E)))
L (cond ((member (car chars) '#.(exploden "01234567890."))
(push (pop chars) temp) (go L)))
E (return (cond (temp (readlist (nreverse temp))))))))
result)))
(go L)))
;this takes the output list from gf-parse1 and does some second order
;processing on it. The sequence is checked to see that all of
;the commands which appear in pairs are properly nested. Parentheses
;are converted to what they are an abbreviation for. Commands that can
;only appear in certain contexts (such as <, >) are checked to see that
;they are in the right place.
(defun GF-parse2 (list)
(prog (result c balance)
L (cond ((null list) (return (nreverse result))))
(setq c (pop list))
(cond ((and (memq c '(< PERIOD))
(not (memq (car balance) '(GO-IN OPEN))))
(error '|GF - < and . must be immediately in [] or ()| nil)))
(cond ((and (memq c '(CLOSE GO-OUT END-SUB >))
(not (eq c (cdr (assq (pop balance)
'((OPEN . CLOSE) (GO-IN . GO-OUT)
(START-SUB . END-SUB) (< . >)))))))
(error '|GF - unmatched brackets| nil)))
(caseq c
(OPEN
(cond ((Gfirst '(GO-IN OPEN) '(START-SUB) balance)
(push 'START-SUB result)))
(setq result (append `(GO-IN '|(| QUOTE ,(pop list) START) result)))
(CLOSE
(setq result (append '(END '|)| QUOTE GO-OUT) result))
(cond ((Gfirst '(GO-IN OPEN) '(START-SUB) balance)
(push 'END-SUB result))))
((QUOTE & % $ START ← T) (push c result) (push (pop list) result))
(T (push c result)))
(cond ((memq c '(OPEN GO-IN START-SUB <))
(push c balance)))
(go L)))
;This returns T if it finds an element of HITS in the LIST before an element
;of MISSES. NIL if it doesn't find either.
(defun Gfirst (hits misses list)
(do ((l list (cdr l)))
((null l) nil)
(cond ((memq (car l) hits) (return T))
((memq (car l) misses) (return nil)))))
;This passes over the token list a third time, adding in the
;appropriate information from the args. Each # is replaced by an arg,
;and each thing that requires an input (ie [] P C S I % $ E) gets an
;input. Note that this input precedes the parameter for % and $.
;Also note that if the format is nested inside [] then it doesn't use
;up an input but rather an internal variable (except for E which still
;uses an input). The commands NEXT and NEXTP are inserted at the
;proper points where the internal stepping variables should be
;advanced.
; The length of the list stored in the variable NESTED shows how far
;deep in [] you are. This variable also stores saved values of period
;which says whether or not you have encountered a period command.
(defun GF-parse3 (list args)
(prog (period nested result c)
L (cond ((null list)
(cond (args (error "GF - too many args" args)))
(return (nreverse result))))
(setq c (pop list))
(push c result)
(cond ((memq c '(GO-IN P C S I * % $ START-SUB))
(cond (nested (push (cond (period '|gf|) (T '(car |gf|))) result))
((null args) (error "GF - Too few args" nil))
(T (push (pop args) result)))))
(cond ((memq c '(QUOTE & % $ START ← T))
(cond ((not (eq (car list) '|#|)) (push (pop list) result))
((null args) (error "GF - Too few args" nil))
(T (pop list) (push (pop args) result)))))
(cond ((eq c 'E)
(cond ((null args) (error "GF - Too few args" nil))
(T (push (pop args) result)))))
(cond ((memq c '(GO-OUT END-SUB)) (setq period (pop nested))))
(cond ((and (memq c '(GO-OUT P C S I * % $ END-SUB)) nested (not period))
(cond ((Gfirst '(PERIOD)
'(GO-IN GO-OUT P C S I * % $ START-SUB END-SUB)
list)
(push 'XP result))
(T (push 'X result)))))
(caseq c
(PERIOD (setq period T))
(GO-IN (push period nested) (setq period nil))
(START-SUB (push period nested) (setq period T)))
(go L)))
;This groups the [] and subtemplates up into sublists. The end marker is
;discarded, and the entire subgroup becomes a list after the head. Note that
;the argument is not included and stays seperate. Note that we already know
;that everything matches up.
(declare (special GF-group-list))
(defun GF-group (GF-group-list) (GF-group1))
(defun GF-group1 ()
(prog (result c)
L (cond ((null GF-group-list) (return (nreverse result))))
(setq c (pop GF-group-list))
(caseq c
((GO-OUT END-SUB) (return (nreverse result)))
((GO-IN START-SUB)
(push c result) (push (pop GF-group-list) result)
(push (GF-group1) result))
((P C S I QUOTE * & START ← T)
(push c result) (push (pop GF-group-list) result))
((% $)
(push c result) (push (pop GF-group-list) result)
(push (pop GF-group-list) result))
(T (push c result)))
(go L)))
;This produces the code. There is a simple code template for each
;kind of command. Note the way it recurses.
(defun GF-code (list)
(prog (result)
L (cond ((null list) (return (nreverse result))))
(push
(caseq (pop list)
(GO-IN `(let ((|gf| ,(pop list)))
(prog ()
(cond ((not (#Mpairp #Qlistp |gf|)) (return nil)))
.,(GF-code (pop list)))))
(X `(cond ((GF-end (setq |gf| (cdr |gf|))) (return nil))))
(XP `(setq |gf| (cdr |gf|)))
(PERIOD 'PERIOD)
(< `L)
(> `(go L))
(P `(GQ Gatom-pcode ,(pop list)))
(C `(GQ ':princ ,(pop list)))
(S `(GQ ':special ,(pop list)))
(I (pop list))
(QUOTE `(GQ ':special ,(pop list)))
(* `(Gdispatch nil ,(pop list)))
(& `(funcall ,(pop list)))
(% (let ((arg (pop list)) (fn (pop list))) `(funcall ,fn ,arg)))
($ (let ((arg (pop list)) (fn (pop list))) `(Gdispatch ,fn ,arg)))
(START-SUB (let ((arg (pop list)) (code (GF-code (pop list))))
`(Gdispatch #'(lambda (|gf|) .,code) ,arg)))
(START `(GQ ':start ,(pop list)))
(END `(GQ ':end nil))
(A `(GQ ':newline ':always))
(N `(GQ ':newline ':normal))
(B `(GQ ':newline ':block))
(← `(GQ ':space ,(or (pop list) 1)))
((T) `(GQ ':tab ,(pop list)))
(E `(GQ ':eval ,(pop list)))
(T (error "GF - internal bug GF-code" nil)))
result)
(go L))) )
;this implements the standard end test used in the functions produced
;by GF.
(defun GF-end (sublist)
(cond ((null sublist))
((not (listp sublist))
(GF "←B{0'. '*}" sublist) T)
((Gabbrev-length (null (cdr sublist)) (car sublist)))))
;this tests whether the length abbreviation limit has been exceeded.
(defun Gabbrev-length (is-last next-item)
(cond ((let ((len (cond ((= Gprinlevel (Glevel)) 2) (t Gprinlength))))
(cond ((> (Glength) len))
((< (Glength) len) nil)
((null is-last))
((= Gprinlevel (Glevel)) nil)
((or (symbolp next-item) (numberp next-item)) nil)
(T T)))
(setq Gabbreved T)
(GF "←B'...'") T)))
;this saves you from having to make a lot of declarations in MacLisp
#M(cond ((fboundp '*fexpr)
(*fexpr plp)
(*lexpr Gprint1 Gprintc Gprint Gexplode Gexplodec)
(*expr Gdispatch GQ GF-end)
(special Gcheckrecursion prinstartline prinendline Gatom-pcode)))
;this is a macro used only on this page to make the definitions easier
(defun defGprin macro (body)
(let ((name (cadr body))
(pcode (caddr body))
(exploding (cadddr body))
(print-like (cadddr (cdr body))))
`(defun ,name (obj &optional (file nil)
(format nil)
(Gprinlevel prinlevel)
(Gprinlength prinlength)
(Gprinendline prinendline)
(Gprinstartline prinstartline)
&aux (Gatom-pcode ',pcode)
(Gexploding ,exploding))
(Gformat-obj ,print-like format obj file))))
;the following are the main user functions for calling the Gprinter
;they are all in the form of a call on Gformat-obj.
(defGprin Gprint1 :prin1 nil nil)
(defGprin Gprintc :princ nil nil)
(defGprin Gprint :prin1 nil T)
(defGprin Gexplode :prin1 (ncons nil) nil)
(defGprin Gexplodec :princ (ncons nil) nil)
;this is an incompatable version of an obsolete function. it is useful
;for printing something out with no abbreviation.
(defun pl (obj &optional (file #Mnil #Qstandard-output) (format nil))
(Gprint obj file format nil nil nil nil) #Q(values))
;this is available for setting up the suggested printing environment. it MUST
;BE CALLED BY THE USER if you want it to happen.
;The next page shows the definitions of all this for the LISPM.
#M
(defun Gset-up-printer ()
(sstatus ttyint #↑S 'Gprintabort)
(sstatus ttyint #↑C 'Gcontinue)
(sstatus ttyint #↑P 'Greprint)
(setq prin1 'Gprint1))
;this sets things up on the LISPM. (see TV:KBD-ESC in
;LMWIN;BASSTR > to learn about TV:*ESCAPE-KEYS*).
#Q
(defun Gset-up-printer ()
(cond ((not (assoc #o220 TV:*ESCAPE-KEYS*))
(push '(#o220 :Gprintabort "Stop Gprinting" :keyboard-process)
TV:*ESCAPE-KEYS*)
(push '(#o222 :Greprint "Continue Gprinting; arg re-Gprints in full"
:keyboard-process)
TV:*ESCAPE-KEYS*)))
(setq prin1 'Gprint1))
;FORMAT interface. This makes }N (}G is taken already) be GPRINT1 and
;}:N be GPRINTC. Numeric pre-arguments are taken to be prinlevel,
;prinlength, etc. Note there is a possible bug here if you use FORMAT NIL
;with a long thing because you are going to get crlfs in your output.
#Q
(defun (format:n format:format-ctl-one-arg) (obj args)
(apply (cond (format:colon-flag 'Gprintc) (T 'Gprint1))
(list* obj nil nil args)))
;this function prints out parts of plists and function cells. It fills
;the same cultural niche as GRINDEF but is simpler and incompatable.
;it takes in a sequence of arguments unevaluated. each one is either
;an atom in which case all of the properties and other aspects of the atom
;are printed out, or a list where the car is an atom, and the cdr is a list of
;properties to be printed (:VALUE means the value cell, :FUNCTION means the
;function cell (most recent functional deffn for MACLISP)). If you give it
;no arguments at all it does whatever it did last again.
(defun plp fexpr (arg)
(setq plp (or arg plp))
(prog (list arg)
(setq list plp)
L (cond ((null list) (return nil)))
(setq arg (pop list))
(cond ((cdr plp) (terpri) (princ " ;for the symbol ")
(prin1 (cond ((atom arg) arg) (T (car arg))))))
(let* ((symbol (cond ((atom arg) arg) (T (car arg))))
(props (cond ((atom arg) plp-properties) (T (cdr arg))))
(print-header (or (atom props) (cdr props)))
(save))
(cond ((and (or (atom props) (memq ':value props)) (boundp symbol))
(plp2 symbol nil (symeval symbol) 'value print-header)))
(cond ((and (or (atom props) (memq ':function props)) (fboundp symbol))
#Q(let ((fn (fsymeval symbol)))
(cond ((and (listp fn) (eq (car fn) 'macro))
(plp2 symbol 'macro (cdr fn) 'fncell print-header))
(T (plp2 symbol 'expr fn 'fncell print-header))))
#M(setq save (getl symbol '(expr fexpr macro subr lsubr fsubr)))
#M(plp2 symbol (car save) (cadr save) 'prop print-header)))
(do ((p (plist symbol) (cddr p)))
((null p))
(cond ((eq p save))
((or (atom props) (memq (car p) props))
(plp2 symbol (car p) (cadr p) 'prop print-header)))))
(go L))
#Q(values))
(defun plp2 (symbol prop val type print-header)
(cond ((and (not (eq type 'value)) (listp val)
(memq (car val) '(lambda named-lambda named-subst)))
(setq type (cond ((eq (car val) 'named-subst) 'defsubst) (T 'defun)))
(setq val
`(defun ,(cond ((eq prop 'expr) symbol) (T `(,symbol ,prop)))
.,(cond ((eq (car val) 'lambda) (cdr val))
(T (cddr val)))))))
(cond ((null print-header) (Gprint val nil nil nil nil nil nil))
(T (Gprint (cons (caseq type
(defun nil)
(value '(|Value - |))
(fncell '(|Function cell - |))
(prop `(|| ,prop | property - |)))
val)
nil #'(lambda (x) (GF "[[';'CPC]B.*]" x))
nil nil nil nil))))
;this should be put on an interrupt character i.e. (sstatus ttyint 19.
;'Gprintabort) it enables you to stop printing in the middle of
;something.
#M
(defun Gprintabort (ignore ignore-ch)
(nointerrupt nil) (tyi tyi)
(cond (Gnowprinting (*throw 'Gprintabort '|aborted|))))
;this allows you to continue output which was truncated because it was
;too many lines long. It is only intended to work for tty output
#M
(defun Gcontinue (ignore ignore-ch)
(nointerrupt nil) (tyi tyi) (Gredo nil))
#M
(defun Greprint (ignore ignore-ch)
(nointerrupt nil) (tyi tyi) (Gredo T))
;this does the actual reprinting. note that if you ask for a full
;reprinting, and you are ABOVE the place where the printing happended
;last time, it just does the printing at the plae where you are instead
;of going back to the old spot.
(defun Gredo (all?)
(cond ((and Gtruncated (car Gtruncated))
(let* ((initial-line (nth 0 Gtruncated))
(final-line (nth 1 Gtruncated))
(initial-charpos (nth 2 Gtruncated))
(mainfile (nth 3 Gtruncated))
(params (nth 4 Gtruncated))
(form (nth 5 Gtruncated))
(current-line (car (Gcursorpos mainfile)))
(start-line (cond (all? (min current-line initial-line))
(T final-line))))
(Gcursorpos start-line initial-charpos mainfile)
(Gcursorpos 'l mainfile)
(let ((Gprinlevel (cond (all? 6400.) (T (nth 0 params))))
(Gprinlength (cond (all? 6400.) (T (nth 1 params))))
(Gprinendline (cond (all? 6400.) (T (nth 2 params))))
(Gprinstartline (cond (all? 0) (T (nth 3 params))))
(Gatom-pcode (nth 4 params))
(Gexploding nil))
(eval form))
(cond ((not (= final-line current-line)) (terpri mainfile)))
(cond ((not all?) ;so can ↑P after ↑C
(rplaca Gtruncated initial-line)))))))
#Q
(defun Ginterrupt-current-process (form)
(let ((p (and tv:selected-window
(funcall tv:selected-window ':process))))
(cond (p (funcall p ':interrupt 'eval form)))))
#Q
(defun Gprintabort (ignore)
(Ginterrupt-current-process
'(cond (Gnowprinting (*throw 'Gprintabort '|aborted|)))))
#Q
(defun Greprint (all?)
(Ginterrupt-current-process (list 'gredo all?)))
;this is the main entry function into the internals of the printer.
;it sets up the initial values of all of the internal globals and fires up the
;format functions.
(defun Gformat-obj (print-like format obj file)
(setq Gprinlevel (or Gprinlevel 64000.)
Gprinlength (or Gprinlength 64000.)
Gprinendline (or Gprinendline 64000.)
Gprinstartline (or Gprinstartline 0.))
#Q(cond ((null file) (setq file standard-output))
((eq file T) (setq file terminal-io)))
#M(cond ((not (or (null file) (eq (typep file) 'list)))
(setq file (ncons file))))
#M(setq file (subst tyo t file))
(cond ((and print-like (null Gexploding) (not (plusp Gprinstartline))
(plusp Gprinendline))
(terpri file)))
(let* ((Gout file)
(Gmainfile #M(or (car Gout) (and ↑r ↑w (car outfiles)) tyo) #QGout)
(initial-cursorpos (Gcursorpos Gmainfile))
(Ginitial-charpos (cond (print-like 0) (T (Gcharpos Gmainfile))))
(Glinelen (- (Glinel Gmainfile) Ginitial-charpos 5))
(Gfreelen Glinelen)
(Glineno 0)
(Gpending 0)
(Gpending-newline nil)
(Gdepth 0)
(Gqueue (cond (Gnowprinting (array nil nil 60.)) (Gqueue)
((setq Gqueue (array nil nil 300.)))))
(Gql 0)
(Gqr 0)
(Gqs (cond (Gnowprinting (array nil fixnum 20.)) (Gqs)
((setq Gqs (array nil fixnum 120.)))))
(Gqsp 0)
(Gps (cond (Gnowprinting (array nil fixnum 10.)) (Gps)
((setq Gps (array nil fixnum 60.)))))
(Gpsp 0)
(Gparents (cond (Gnowprinting (array nil nil 10.)) (Gparents)
((setq Gparents (array nil nil 50.)))))
(Gabbreved nil)
(Grptr -1)
(Gtsize 0)
(Glsize 0))
(setf (Gbegin) -1)
(setf (Glevel) 0)
(setf (Glength) 0)
(setf (Gsave-Gtsize) 0)
(setf (Gtabsize) -1)
(setf (Gpindent) 0)
(cond (#MGforce-mores
#Q(and Gforce-mores
(memq ':home-cursor (funcall Gmainfile ':which-operations)))
(Gcursorpos 't Gmainfile)
(Gcursorpos (car initial-cursorpos)
(cdr initial-cursorpos)
Gmainfile)))
(cond (Gshow-errors (Gformat-obj1 obj print-like format))
((errset (Gformat-obj1 obj print-like format)))
((errset (progn (princ '|error while GPRINTing:|) (print obj))))
(T (terpri) (princ '|error while PRINTing |)
#M(princ '|MUNKAM of |) #M(princ (maknum obj))))
(cond ((and Gabbreved (null Gexploding) initial-cursorpos)
(setq Gtruncated
`(,(car initial-cursorpos) ,(car (Gcursorpos Gmainfile))
,Ginitial-charpos ,Gmainfile
(,Gprinlevel ,Gprinlength 64000. ,Glineno ,Gatom-pcode)
(Gformat-obj nil ',format ',obj ',Gmainfile)))))
(cond (Gexploding (cdr (nreverse Gexploding)))
(T #MT #Q(values)))))
(defun Gformat-obj1 (obj print-like format)
(or (null (*catch 'Gprintabort
(let* ((Gnowprinting T)
(prin1 nil))
(GF "$#" obj format)
(cond (print-like (GF "' '"))))))
(setq Gabbreved T)))
;this is a local macro used only in the next function.
;this checks to see if any of a list of special formatters is appropriate.
(defun Gselect macro (body)
(let ((list (cadr body)) (default (caddr body)))
(displace body
`(cond ((do ((fns ,list (cdr fns)))
((null fns) ,(cond ((null default) nil)
((atom default) `(,default obj))
(T `(funcall ,default obj))))
(cond ((funcall (car fns) obj) (return T)))))))))
;this is the basic dispatch routine that decides what to do based on the
;type of the object to print. (It takes care of depth abbreviation, and
;checks for circularity abbreviation.) Special format functions can be put
;on the variables Gspecial-formatters, Glist-formatters, Ghunk-formatters, and
;Garray-formatters. They should return T when they succeed.
;all of the standard tests are inline coded for speed.
(defun Gdispatch (Gsuggested-format obj)
(let ((Grptr Grptr))
(cond (Gcheckrecursion (setq obj (Gcheckrecursion obj))))
(cond ((not (or (< (Glevel) Gprinlevel) (symbolp obj) (numberp obj)))
(setq Gabbreved T) (GF "C" Gprinlevel-abbrev))
((Gselect Gspecial-formatters nil))
((or (symbolp obj) (numberp obj) #Q(stringp obj)) (GF "P" obj))
((listp obj)
(cond ((Gselect Goverriding-list-formatters nil))
(Gsuggested-format (funcall Gsuggested-format obj))
(T (Gselect Glist-formatters
(let* ((head (car obj)))
(cond ((symbolp head)
(cond ((get head ':Gformat))
((fboundp head) Gfn-format)
(T Gsymbol-car-format)))
((and (listp head)
(memq (car head)
'(lambda named-lambda named-subst)))
Gapply-format)
(T Gnon-symbol-car-format)))))))
#M((hunkp obj)
(let* ((usrhunk (status usrhunk))
(sendi (status sendi))
(ops (and usrhunk (funcall usrhunk obj)
(funcall sendi obj ':which-operations))))
(cond ((memq ':Gformat-self ops)
(funcall sendi obj ':Gformat-self obj))
((or (memq ':print-self ops) (memq 'print ops))
(GF "P" obj))
((Gselect Ghunk-formatters Gformat-hunk)))))
#Q((named-structure-p obj)
(cond ((let ((name (named-structure-symbol obj)))
(and (symbolp name)
(get name 'named-structure-invoke)
(memq ':Gformat-self
(named-structure-invoke obj ':which-operations))))
(named-structure-invoke obj ':Gformat-self obj))
(T (GF "P" obj))))
#Q((and (or (typep obj ':entity) (typep obj ':instance))
(memq ':Gformat-self (funcall obj ':which-operations)))
(funcall obj ':Gformat-self obj))
((eq (typep obj) #M'array #Q':array)
(Gselect Garray-formatters Gformat-array))
(T (GF "P" obj)))))
;this checks to see if the thing has been encountered before.
;note lists are treated specially because they are the only data
;structure which has a horizontal structure which can be circular.
;(Due to the fact that each list is treated as an indivisable structure,
;if some element of a list points to some internal cdr of a list it is
;inside, the circularity will not be detected as soon as you might think,
;but the printer won't blow up.)
;Note that Gdispatch is the only place where circularity is checked.
;if you following any pointers without calling Gdispatch on EACH new
;structure, all bets are off circularity-wise.
(defun Gcheckrecursion (thing)
(setq Grptr (1+ Grptr))
(cond ((not (< Grptr (array-dimension-n 1 Gparents)))
(*rearray Gparents nil (+ Grptr 20))))
(store (arraycall nil Gparents Grptr) thing)
(cond ((Gcheckrecursion1 thing))
((#Mpairp #Qlistp thing) (Gcheckrecursion-list thing))
(T thing)))
;note that this works hard so that there is no consing when there
;is no circularity.
(defun Gcheckrecursion-list (thing)
(do ((lst (cdr thing) (cdr lst))
(n 1 (1+ n)))
((not (#Mpairp #Qlistp lst)) thing)
(let ((rec (or (Gcheckrecursion1 lst)
(Gcrl1 lst thing n))))
(cond (rec (return (do ((l (cdr thing) (cdr l))
(r (ncons (car thing)) (cons (car l) r))
(i (1- n) (1- i)))
((zerop i)
(prog1 (nreverse r) (rplacd r rec))))))))))
(defun Gcrl1 (lst thing n)
(do ((l thing (cdr l))
(i n (1- i)))
((zerop i) nil)
(cond ((eq l lst)
(return (let ((*nopoint T))
(intern (format nil "%}a" i))))))))
(defun Gcheckrecursion1 (thing)
(do ((i (1- Grptr) (1- i)))
((minusp i) nil)
(cond ((eq thing (arraycall nil Gparents i))
(return (let ((*nopoint T))
(intern (format nil "↑}a" (- Grptr i)))))))))
;this prints out a hunk in the standard MacLisp way.
#M
(defun Gformat-hunk (hunk)
(GF "{1'('")
(prog (j end)
(setq end (hunksize hunk)
j (cond ((= end 1) 0) (T 1)))
L (GF "B*' .'" (cxr j hunk))
(cond ((zerop j) (return nil)))
(setq j (1+ j))
(cond ((= j end) (setq j 0)))
(GF "←")
(cond ((Gabbrev-length (= j 0) (cxr j hunk)) (return nil)))
(go L))
(GF "')'}"))
;this prints out an array by printing out what is in it. It first
;just prints out what the normal printer would, and then prints out
;the things inside (if GPRINT-ARRAY-CONTENTS is T), using sublists if
;the array is multi-dimensional. This only does fancy stuff for single and
;double dimensioned arrays at the current time.
(defun Gformat-array (array)
(GF "{2P" array)
(cond ((null Gprint-array-contents))
(T (let ((dims (arraydims array)))
(and #M(memq (car dims) '(fixnum flonum T nil))
(not (zerop (cadr dims)))
(caseq (length (cdr dims))
(1 (Gformat-array-1 array dims))
(2 (Gformat-array-2 array dims)))))))
(GF "}"))
(defun Gformat-array-1 (array dims)
(GF "' contains'←N")
(cond ((not (< (Glevel) Gprinlevel))
(setq Gabbreved T)
(GF "C" Gprinlevel-abbrev))
(T (GF "{1'['")
(prog (j end type)
(setq type (car dims)
end (1- (cadr dims))
j 0)
L (GF "TB*" #Q(aref array j)
#M(caseq type
(fixnum (arraycall fixnum array j))
(flonum (arraycall flonum array j))
(T (arraycall nil array j))))
(setq j (1+ j))
(cond ((> j end) (return nil)))
(cond ((Gabbrev-length (= j end) '(nil)) (return nil)))
(GF "←")
(go L))
(GF "']'}"))))
(defun Gformat-array-2 (array dims)
(GF "' contains'←N")
(cond ((not (< (Glevel) Gprinlevel))
(setq Gabbreved T)
(GF "C" Gprinlevel-abbrev))
(T (GF "{1'['")
(prog (j end)
(setq end (1- (cadr dims))
j 0)
L (Gformat-array-2-1 array j dims)
(setq j (1+ j))
(cond ((> j end) (return nil)))
(cond ((Gabbrev-length (= j end) '(nil)) (return nil)))
(GF "←N")
(go L))
(GF "']'}"))))
(defun Gformat-array-2-1 (array i dims)
(cond ((not (< (Glevel) Gprinlevel))
(setq Gabbreved T)
(GF "C" Gprinlevel-abbrev))
(T (GF "{1'['")
(prog (j end type)
(setq type (car dims)
end (1- (caddr dims))
j 0)
L (GF "TB*" #Q(aref array i j)
#M(caseq type
(fixnum (arraycall fixnum array i j))
(flonum (arraycall flonum array i j))
(T (arraycall nil array i j))))
(setq j (1+ j))
(cond ((> j end) (return nil)))
(cond ((Gabbrev-length (= j end) '(nil)) (return nil)))
(GF "←")
(go L))
(GF "']'}"))))
;this section contains list formatters.
;note that most of these templates are effecient but obscure!
;this macro defines a format, but only if you haven't defined one yet!
;this is so that loading Gprint won't overwrite formats you write.
(defmacro defun-default-Gformat (atom args . body)
(let ((fn (intern (format nil "}a-:Gformat" atom))))
`(eval-when (eval load)
(defun ,fn ,args .,body)
(defprop-default-Gformat ',atom ',fn))))
(defun defprop-default-Gformat (atom fn)
(cond ((null (get atom ':Gformat))
(putprop atom fn ':Gformat))))
;first we have some of general utilities that you can use
;inside formats you create or as the format argument of GPRINT.
(defun :Gfn-format (x) (GF "(*←<*←N>)" x))
(defun :GTblock (x) (GF "(1<TB$:GTblock ←>)" x))
(defun :G1Tblock (x) (GF "(1<TB*←>)" x))
(defun :Gblock (x) (GF "(1<$:Gblock ←B>)" x))
(defun :G1block (x) (GF "(1<*←B>)" x))
(defun :Gmiser (x) (GF "(1<$:Gmiser ←N>)" x))
(defun :G1miser (x) (GF "(1<*←N>)" x))
(defun-default-Gformat :Gnothing (ignore) nil)
(defun-default-Gformat :Gunterpri (ignore) (GQ ':eval '(:Gunterpri Gmainfile)))
(defun :Gunterpri (file)
(let ((pos (car (Gcursorpos file))))
(cond ((and pos (> pos 0))
(Gcursorpos (1- pos) (1- (Glinel file)) file)))))
(defun-default-Gformat setq (x) (GF "(*←*<←B*←A*>)" x))
(defun-default-Gformat setf (x) (GF "(*←*<←B*←A*>)" x))
(defun-default-Gformat quote (x)
(cond ((and (cdr x) (null (cddr x))) (GF "{0''''*}" (cadr x)))
(T (:Gfn-format x))))
(defun-default-Gformat function (x)
(cond ((and (cdr x) (null (cddr x))) (GF "{0'#'''*}" (cadr x)))
(T (:Gfn-format x))))
(defun-default-Gformat |`-expander/|| (x) (GF "{0'`'*}" (cdr x)))
(defun-default-Gformat |`,/|| (x) (GF "{0','*}" (cdr x)))
(defun-default-Gformat |`,@/|| (x) (GF "{0',@'*}" (cdr x)))
(defun-default-Gformat |`,./|| (x) (GF "{0',.'*}" (cdr x)))
(defun-default-Gformat |`.,/|| (x) (GF "{0'.,'*}" (cdr x)))
;Note that '`(a .,d) doesn't print right because the marker is not a list car.
;this makes the Gprinter obay the grind-macroexpanded flag from the
;file DEFMAX so that macro expansions print pretty.
(defun-default-Gformat macroexpanded (obj)
(GF "*" (cond (grind-macroexpanded (cadddr (cdr obj)))
(t (cadddr obj)))))
;This makes si:displaced things come out right.
#Q
(defun-default-Gformat si:displaced (obj)
(GF "*" (cadr obj)))
;this makes defun print out right by checking whether it is of the one or two
;keyword form.
(defun-default-Gformat defun (obj)
(cond ((or (memq (cadr obj) '(expr fexpr macro))
(memq (caddr obj) '(expr fexpr macro)))
(GF "(2*←*←*←$:Gblock <←N*>)" obj))
(T (GF "(2*←(*←*)←$:Gblock <←N*>)" obj))))
;the following fns just check for indentation changes and then print
;out the forms
(defun :Gapply-format (list)
(Gcheck-indentation list #'(lambda (x) (GF "(1<*←B>)" x))))
(defun-default-Gformat lambda (list)
(Gcheck-indentation list
#'(lambda (x) (GF "(2*←$:Gblock <←N*>)" x))))
(defun-default-Gformat named-lambda (list)
(Gcheck-indentation list
#'(lambda (x) (GF "(2*←*←$:Gblock <←N*>)" x))))
(defun-default-Gformat named-subst (list)
(Gcheck-indentation list
#'(lambda (x) (GF "(2*←*←$:Gblock <←N*>)" x))))
(defun-default-Gformat let (list)
(Gcheck-indentation list
#'(lambda (x) (GF "(2*←(1(1$:Gblock ←B*) <←N$/"A(1$:Gblock ←B*)/" >)
<←N*>)" x))))
(defun-default-Gformat let* (list)
(Gcheck-indentation list
#'(lambda (x) (GF "(2*←(1(1$:Gblock ←B*) <←N$/"A(1$:Gblock ←B*)/" >)
<←N*>)" x))))
;this makes cond come out right, and makes T clauses look well.
(defun-default-Gformat cond (x) (GF "(*←<$Gcond-format2 ←N>)" x))
(defun Gcond-format2 (list)
(cond ((eq (car list) T)
(GF "(*←<*←N>)" list))
(T (GF "(1<*←N>)" list))))
;this takes care of making the tags come out right in a prog. It works
;even if there are two or more tags in a row.
(declare (special Gdefault-spaces Gspaces))
(defun-default-Gformat prog (list)
(let* ((Gdefault-spaces 5) (Gspaces 5))
(Gcheck-indentation list
#'(lambda (x) (GF "(0*←$:Gblock <%Gprog-format2 >)" x)))))
(defun Gprog-format2 (item)
(cond ((= Gspaces Gdefault-spaces) (GF "A' '")))
(cond ((atom item)
(setq Gspaces (- Gspaces 1 (flatsize item)))
(GF "P←" item))
(T (GF "←#*" (max Gspaces 0) item)
(setq Gspaces Gdefault-spaces))))
;do can be handled much like prog.
(defun-default-Gformat do (list)
(let* ((Gdefault-spaces 3) (Gspaces 3))
(Gcheck-indentation list
#'(lambda (x) (GF "(2*←(1<(*←B*←B*)A>)A' '*<A*>)" x)))))
;this checks to see if the maximum reasonable indentation has been
;exceeded, and if so reduces the indentation
(defun Gcheck-indentation (item format-fn)
(let ((ind (Gestimate-indent)))
(cond ((< ind (// Glinelen 2)) (GF "%#" item format-fn))
(T (GF "A{#A';----------'←#'|'
A' '%#
A';----------'←#'|'}A"
(- ind) (max (- ind 11.) 0)
item format-fn
(max (- ind 11.) 0))))))
;This looks down the queue, and estimates what the indentation will be
;when everything now in the queue is printed if the substructures have
;to be broken up.
(defun Gestimate-indent ()
(let ((indent (Gpindent))
(Gql Gql))
(prog ()
L (cond ((not (< Gql Gqr)) (return nil)))
(cond ((and (eq (Gtype) ':start) (null (Gsize)))
(setq indent
(max (+ indent (or (Gobj) (Gdetermine-indent))) 0))))
(Gpop Gqueue)
(go L))
indent))
;this makes backquote grind right on the LISPM.
#Q(defun-default-Gformat si:xr-bq-cons (obj)
(GF "{0'`'*}" (Gunbackquotify obj)))
#Q(defun-default-Gformat si:xr-bq-list (obj)
(GF "{0'`'*}" (Gunbackquotify obj)))
#Q(defun-default-Gformat si:xr-bq-list* (obj)
(GF "{0'`'*}" (Gunbackquotify obj)))
#Q(defun-default-Gformat si:xr-bq-append (obj)
(GF "{0'`'*}" (Gunbackquotify obj)))
#Q(defun-default-Gformat si:xr-bq-nconc (obj)
(GF "{0'`'*}" (Gunbackquotify obj)))
;Convert the backquote form to a list resembling what the user typed in,
;with "calls" to |`,/||, etc., representing the commas.
;Lifted from lmio;grind.
#Q
(defun Gunbackquotify (exp)
(cond ((or (numberp exp) (eq exp t) (null exp) (stringp exp)) exp)
((symbolp exp) `(|`,/|| . ,exp))
((atom exp) exp)
((eq (car exp) 'quote) (cadr exp))
((eq (car exp) 'si:xr-bq-cons)
(cons (Gunbackquotify (cadr exp))
(Gunbackquotify-segment (cddr exp) nil t)))
((eq (car exp) 'si:xr-bq-list)
(mapcar 'Gunbackquotify (cdr exp)))
((eq (car exp) 'si:xr-bq-list*)
(nconc (mapcar 'Gunbackquotify (butlast (cdr exp)))
(Gunbackquotify-segment (last exp) nil t)))
((eq (car exp) 'si:xr-bq-append)
(mapcon 'Gunbackquotify-segment (cdr exp)
(circular-list t) (circular-list nil)))
((eq (car exp) 'si:xr-bq-nconc)
(mapcon 'Gunbackquotify-segment (cdr exp)
(circular-list nil) (circular-list nil)))
(t `(|`,/|| . ,exp))))
;Convert a thing in a backquote-form which should appear as a segment,
;not an element. The argument is the list whose car is the
;segment-form, and the value is the segment to be appended into the
;resulting list.
#Q
(defun Gunbackquotify-segment (loc copy-p tail-p)
(cond ((and tail-p (atom (cdr loc)))
(let ((tem (Gunbackquotify (car loc))))
(cond ((and (listp tem) (eq (car tem) '|`,/||))
(list `(|`.,/|| . ,(car loc))))
(t tem))))
((and (listp (car loc))
(eq (caar loc) 'quote)
(listp (cadar loc)))
(cadar loc))
(t (list (cons (if copy-p '|`,@/|| '|`,./||)
(car loc))))))
;this creates queue entries.
(defun GQ (type obj)
;make a new entry in the queue.
(setf (Gtype Gqr) type)
(setf (Gobj Gqr) obj)
(setf (Gsize Gqr) (caseq type
(:start nil)
(:newline (cond ((memq obj '(:always :normal)) 0)))
(:prin1 (flatsize obj))
((:princ :special) (flatc obj))
(:space obj)
((:end :tab :eval) 0)))
;do special processing for start and end of a substructure.
(caseq type
(:start (let ((i (Glevel)))
(Gpush Gqs)
(setf (Gbegin) Gqr)
(setf (Gsave-Gtsize) Gtsize)
(setf (Glevel) (cond ((equal obj 0) i) (T (1+ i))))
(setf (Glength) 0)))
(:end (cond ((not (minusp (Gbegin)))
(setf (Gsize (Gbegin)) (- Gtsize (Gsave-Gtsize)))
(Gupdate-sizes (Gbegin))))
(Gpop Gqs)))
;update the total size
(cond ((memq type '(:princ :prin1 :special :space))
(setf Gtsize (+ Gtsize (Gsize Gqr)))))
;update Glength
(cond ((memq type '(:princ :prin1 :end)) (setf (Glength) (1+ (Glength)))))
;if this is a real printing thing then propagate the size to waiting newlines.
(cond ((memq type '(:princ :prin1 :special)) (Gupdate-sizes Gqr)))
;entry is now completely processed.
(Gpush Gqueue)
;check if we can now process any queue entries.
(prog ()
L (cond (Gexploding (Gexplode-it))
((Gsize) (Gprintout))
((or (and (eq type ':newline) (eq obj ':always))
(> (- Gtsize Glsize) Gfreelen))
(setf (Gsize) 64000.)
(Gprintout))
(T (return nil)))
(cond ((memq (Gtype) '(:prin1 :princ :special :space))
(setq Glsize (+ Glsize (Gsize)))))
(Gpop Gqueue)
(cond ((< Gql Gqr) (go L))))
;if the queue was emptied reset it, setting any hanging begins to -1.
(cond ((= Gql Gqr)
(setq Gql 0 Gqr 0 Gtsize 0 Glsize 0)
(let ((Gqsp Gqsp))
(prog ()
L (cond ((minusp Gqsp) (return nil)))
(setf (Gbegin) -1)
(Gpop Gqs)
(go L))))))
;this copies a size back to any newline entries that are waiting.
(defun Gupdate-sizes (ptr)
(do ((i (- ptr 3) (- i 3)))
((or (< i Gql) (not (memq (Gtype i) '(:newline :tab :space :eval)))))
(cond ((null (Gsize i)) (setf (Gsize i) (Gsize ptr))))))
;this processes a queue entry for printing.
(defun Gprintout ()
(caseq (Gtype)
;if it is a start, and won't fit then we must go down in, else just count.
(:start (cond ((and (not (plusp Gdepth))
(> (Gsize) Gfreelen))
(Gpush Gps)
(setf (Gpindent) (max (+ (- Glinelen Gfreelen)
(or (Gobj) (Gdetermine-indent))) 0))
(setf (Gtabsize) -1)
(setq Gdepth -1)))
(setq Gdepth (1+ Gdepth)))
;if it is an end just count the depth change.
(:end (cond ((not (plusp Gdepth)) (Gpop Gps)))
(setq Gdepth (1- Gdepth)))
;if it is some thing to definitely print (or :eval).
((:princ :prin1 :special :eval)
;first see if there is a pending newline we must print.
(cond (Gpending-newline
(cond ((not (< Glineno Gprinendline))
(cond ((plusp Gfreelen) (princ '| ---| Gout)))
(*throw 'Gprintabort '|prinendline exceeded|)))
(cond ((not (< Glineno Gprinstartline))
(terpri Gout)
(setq Gpending (+ Gpending Ginitial-charpos))))
(setq Glineno (1+ Glineno)
Gpending-newline nil)))
;now print this stuff (including any pending blanks).
(cond ((eq (Gtype) ':eval) (eval (Gobj))))
(cond ((not (< Glineno Gprinstartline))
(do ((i Gpending (1- i))) ((zerop i)) (tyo 32. Gout))
(caseq (Gtype)
(:prin1 (prin1 (Gobj) Gout))
((:princ :special) (princ (Gobj) Gout)))))
(setq Gfreelen (- Gfreelen (Gsize)))
(setq Gpending 0))
;if it is a space, then set it up as pending.
(:space (cond ((not Gpending-newline)
(setq Gpending (+ Gpending (Gobj))
Gfreelen (- Gfreelen (Gobj))))))
;if it is a tab we must print, set up appropriate spaces as pending.
(:tab (cond ((and (not (plusp Gdepth)) (not Gpending-newline))
(let* ((tab (cond ((Gobj))
((not (minusp (Gtabsize))) (Gtabsize))
(T (setf (Gtabsize) (Gestimate-Gtabsize))
(Gtabsize))))
(offset (\ (- (- Glinelen Gfreelen) (Gpindent)) tab)))
(cond ((not (zerop offset)) (setq offset (- tab offset))))
(setq Gpending (+ Gpending offset)
Gfreelen (- Gfreelen offset))))))
;if it is a newline, check if we need to really do one.
(:newline
(cond ((and (not (plusp Gdepth))
(caseq (Gobj)
((:always :normal) T)
(:block (and (or (> (Gsize) Gfreelen) (minusp Gdepth))
(< (Gpindent) (- Glinelen Gfreelen))))))
(setq Gpending (Gpindent)
Gfreelen (- Glinelen Gpending)
Gdepth 0
Gpending-newline T))))))
;this looks down the queue and calculates an indentation as the sum of
;the sizes of everything up to and including the first :PRIN1 or
;:PRINC, and any :SPACE after it.
(defun Gdetermine-indent ()
(let ((indent 0)
(found-print nil)
(Gql Gql))
(prog ()
L (Gpop Gqueue)
(cond ((not (< Gql Gqr)) (return nil)))
(caseq (Gtype)
((:prin1 :princ) (cond (found-print (return nil))
(T (setq indent (+ indent (Gsize))
found-print T))))
(:space (setq indent (+ indent (Gsize))))
(:special (cond (found-print (return nil))
(T (setq indent (+ indent (Gsize)))))))
(go L))
indent))
;this looks down the queue and estimates what the Gtabsize should be.
(defun Gestimate-Gtabsize ()
(let ((max 2)
(i 0)
(space (- Glinelen (Gpindent)))
(Gql Gql))
(prog ()
L (cond ((and (zerop i) (numberp (Gsize))) (setq max (max max (Gsize)))))
(caseq (Gtype)
(:start (setq i (1+ i)))
(:end (setq i (1- i))))
(Gpop Gqueue)
(cond ((not (< Gql Gqr)) (return nil)))
(go L))
(setq max (1+ max)) ;to allow for spaces between items
(// space (// space (min space (+ max (// max 5)))))))
;This explodes a thing adding it to Gexploding.
(defun Gexplode-it ()
(caseq (Gtype)
(:space (do ((i (Gobj) (1- 1))) ((zerop i))
(setq Gexploding (cons '| | Gexploding))))
(:prin1 (setq Gexploding (nreconc (explode (Gobj)) Gexploding)))
((:special :princ)
(setq Gexploding (nreconc (explodec (Gobj)) Gexploding)))))